home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / emacs.lha / emacs-19.16 / lisp / electric.el < prev    next >
Lisp/Scheme  |  1993-06-02  |  6KB  |  165 lines
  1. ;;; electric.el --- window maker and Command loop for `electric' modes.
  2.  
  3. ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
  4.  
  5. ;; Author: K. Shane Hartman
  6. ;; Maintainer: FSF
  7. ;; Keywords: extensions
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ; zaaaaaaap
  28.  
  29. ;;; Code:
  30.  
  31. ;; This loop is the guts for non-standard modes which retain control
  32. ;; until some event occurs.  It is a `do-forever', the only way out is to
  33. ;; throw.  It assumes that you have set up the keymap, window, and
  34. ;; everything else: all it does is read commands and execute them -
  35. ;; providing error messages should one occur (if there is no loop
  36. ;; function - which see).  The required argument is a tag which should
  37. ;; expect a value of nil if the user decides to punt. The
  38. ;; second argument is a prompt string (defaults to "->").  Given third
  39. ;; argument non-nil, it INHIBITS quitting unless the user types C-g at
  40. ;; toplevel.  This is so user can do things like C-u C-g and not get
  41. ;; thrown out.  Fourth argument, if non-nil, should be a function of two
  42. ;; arguments which is called after every command is executed.  The fifth
  43. ;; argument, if provided, is the state variable for the function.  If the
  44. ;; loop-function gets an error, the loop will abort WITHOUT throwing
  45. ;; (moral: use unwind-protect around call to this function for any
  46. ;; critical stuff).  The second argument for the loop function is the
  47. ;; conditions for any error that occurred or nil if none.
  48.  
  49. (defun Electric-command-loop (return-tag
  50.                   &optional prompt inhibit-quit
  51.                     loop-function loop-state)
  52.   (if (not prompt) (setq prompt "->"))
  53.   (let (cmd (err nil))
  54.     (while t
  55.       (setq cmd (read-key-sequence (if (stringp prompt)
  56.                        prompt (funcall prompt))))
  57.       (setq last-command-char (aref cmd (1- (length cmd)))
  58.         this-command (key-binding cmd)
  59.         cmd this-command)
  60.       (if (or (prog1 quit-flag (setq quit-flag nil))
  61.           (eq last-input-char ?\C-g))
  62.       (progn (setq unread-command-events nil
  63.                prefix-arg nil)
  64.          ;; If it wasn't cancelling a prefix character, then quit.
  65.          (if (or (= (length (this-command-keys)) 1)
  66.              (not inhibit-quit)) ; safety
  67.              (progn (ding)
  68.                 (message "Quit")
  69.                 (throw return-tag nil))
  70.            (setq cmd nil))))
  71.       (setq current-prefix-arg prefix-arg)
  72.       (if cmd
  73.       (condition-case conditions
  74.           (progn (command-execute cmd)
  75.              (setq last-command this-command)
  76.              (if (or (prog1 quit-flag (setq quit-flag nil))
  77.                  (eq last-input-char ?\C-g))
  78.              (progn (setq unread-command-events nil)
  79.                 (if (not inhibit-quit)
  80.                     (progn (ding)
  81.                        (message "Quit")
  82.                        (throw return-tag nil))
  83.                   (ding)))))
  84.         (buffer-read-only (if loop-function
  85.                   (setq err conditions)
  86.                 (ding)
  87.                 (message "Buffer is read-only")
  88.                 (sit-for 2)))
  89.         (beginning-of-buffer (if loop-function
  90.                      (setq err conditions)
  91.                    (ding)
  92.                    (message "Beginning of Buffer")
  93.                    (sit-for 2)))
  94.         (end-of-buffer (if loop-function
  95.                    (setq err conditions)
  96.                  (ding)
  97.                  (message "End of Buffer")
  98.                  (sit-for 2)))
  99.         (error (if loop-function
  100.                (setq err conditions)
  101.              (ding)
  102.              (message "Error: %s"
  103.                   (if (eq (car conditions) 'error)
  104.                   (car (cdr conditions))
  105.                 (prin1-to-string conditions)))
  106.              (sit-for 2))))
  107.     (ding))
  108.       (if loop-function (funcall loop-function loop-state err))))
  109.   (ding)
  110.   (throw return-tag nil))
  111.  
  112. ;; This function is like pop-to-buffer, sort of. 
  113. ;; The algorithm is
  114. ;; If there is a window displaying buffer
  115. ;;     Select it
  116. ;; Else if there is only one window
  117. ;;     Split it, selecting the window on the bottom with height being
  118. ;;     the lesser of max-height (if non-nil) and the number of lines in
  119. ;;      the buffer to be displayed subject to window-min-height constraint.
  120. ;; Else
  121. ;;     Switch to buffer in the current window.
  122. ;;
  123. ;; Then if max-height is nil, and not all of the lines in the buffer
  124. ;; are displayed, grab the whole frame.
  125. ;;
  126. ;; Returns selected window on buffer positioned at point-min.
  127.  
  128. (defun Electric-pop-up-window (buffer &optional max-height)
  129.   (let* ((win (or (get-buffer-window buffer) (selected-window)))
  130.      (buf (get-buffer buffer))
  131.      (one-window (one-window-p t))
  132.      (pop-up-windows t)
  133.      (target-height)
  134.      (lines))
  135.     (if (not buf)
  136.     (error "Buffer %s does not exist" buffer)
  137.       (save-excursion
  138.     (set-buffer buf)
  139.     (setq lines (count-lines (point-min) (point-max)))
  140.     (setq target-height
  141.           (min (max (if max-height (min max-height (1+ lines)) (1+ lines))
  142.             window-min-height)
  143.            (save-window-excursion
  144.              (delete-other-windows)
  145.              (1- (window-height (selected-window)))))))
  146.       (cond ((and (eq (window-buffer win) buf))
  147.          (select-window win))
  148.         (one-window
  149.          (goto-char (window-start win))
  150.          (pop-to-buffer buffer)
  151.          (setq win (selected-window))
  152.          (enlarge-window (- target-height (window-height win))))
  153.         (t
  154.          (switch-to-buffer buf)))
  155.       (if (and (not max-height)
  156.            (> target-height (window-height (selected-window))))
  157.       (progn (goto-char (window-start win))
  158.          (enlarge-window (- target-height (window-height win)))))
  159.       (goto-char (point-min))
  160.       win)))
  161.  
  162. (provide 'electric)
  163.  
  164. ;;; electric.el ends here
  165.